home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / MacPerl 506 appl folder.sit / MacPerl 506 appl folder / Mac_Perl_506r1m_appl / lib / Getopt / Std.pm < prev    next >
Text File  |  1994-12-26  |  2KB  |  105 lines
  1. package Getopt::Std;
  2. require 5.000;
  3. require Exporter;
  4.  
  5. @ISA = qw(Exporter);
  6. @EXPORT = qw(getopt getopts);
  7.  
  8. # $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
  9.  
  10. # Process single-character switches with switch clustering.  Pass one argument
  11. # which is a string containing all switches that take an argument.  For each
  12. # switch found, sets $opt_x (where x is the switch name) to the value of the
  13. # argument, or 1 if no argument.  Switches which take an argument don't care
  14. # whether there is a space between the switch and the argument.
  15.  
  16. # Usage:
  17. #    getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  18.  
  19. sub getopt {
  20.     local($argumentative) = @_;
  21.     local($_,$first,$rest);
  22.     local $Exporter::ExportLevel;
  23.  
  24.     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  25.     ($first,$rest) = ($1,$2);
  26.     if (index($argumentative,$first) >= 0) {
  27.         if ($rest ne '') {
  28.         shift(@ARGV);
  29.         }
  30.         else {
  31.         shift(@ARGV);
  32.         $rest = shift(@ARGV);
  33.         }
  34.         eval "¥$opt_$first = ¥$rest;";
  35.         push( @EXPORT, "¥$opt_$first" );
  36.     }
  37.     else {
  38.         eval "¥$opt_$first = 1;";
  39.         push( @EXPORT, "¥$opt_$first" );
  40.         if ($rest ne '') {
  41.         $ARGV[0] = "-$rest";
  42.         }
  43.         else {
  44.         shift(@ARGV);
  45.         }
  46.     }
  47.     }
  48.     $Exporter::ExportLevel++;
  49.     import Getopt::Std;
  50. }
  51.  
  52. # Usage:
  53. #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
  54. #            #  side effect.
  55.  
  56. sub getopts {
  57.     local($argumentative) = @_;
  58.     local(@args,$_,$first,$rest);
  59.     local($errs) = 0;
  60.     local $Exporter::ExportLevel;
  61.  
  62.     @args = split( / */, $argumentative );
  63.     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  64.     ($first,$rest) = ($1,$2);
  65.     $pos = index($argumentative,$first);
  66.     if($pos >= 0) {
  67.         if($args[$pos+1] eq ':') {
  68.         shift(@ARGV);
  69.         if($rest eq '') {
  70.             ++$errs unless @ARGV;
  71.             $rest = shift(@ARGV);
  72.         }
  73.         eval "¥$opt_$first = ¥$rest;";
  74.         push( @EXPORT, "¥$opt_$first" );
  75.         }
  76.         else {
  77.         eval "¥$opt_$first = 1";
  78.         push( @EXPORT, "¥$opt_$first" );
  79.         if($rest eq '') {
  80.             shift(@ARGV);
  81.         }
  82.         else {
  83.             $ARGV[0] = "-$rest";
  84.         }
  85.         }
  86.     }
  87.     else {
  88.         print STDERR "Unknown option: $first¥n";
  89.         ++$errs;
  90.         if($rest ne '') {
  91.         $ARGV[0] = "-$rest";
  92.         }
  93.         else {
  94.         shift(@ARGV);
  95.         }
  96.     }
  97.     }
  98.     $Exporter::ExportLevel++;
  99.     import Getopt::Std;
  100.     $errs == 0;
  101. }
  102.  
  103. 1;
  104.  
  105.